home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Franz PD / Franz PD Disk #324 (1994-04)(Rhein-Sieg-Soft).zip / Franz PD Disk #324 (1994-04)(Rhein-Sieg-Soft).adf / VideoText3.5 / source / sys.p < prev    next >
Text File  |  1994-04-01  |  10KB  |  329 lines
  1. UNIT sys {$project vt}
  2. { Betriebssystemnahe Funktionen zum Programm VideoText }
  3.  
  4. INTERFACE;
  5.  
  6. TYPE Str80 = String[80];
  7.  
  8. FUNCTION abbruch_test: Boolean;
  9. FUNCTION readkey: Char;
  10. FUNCTION waitkey: Char;
  11. FUNCTION ja_nein: Boolean;
  12. FUNCTION fileselect(was_los: str80; speichern: boolean;
  13.                                    var selected: str80): Boolean;
  14. PROCEDURE telltime(VAR day,min,tic: Long);
  15. PROCEDURE stretch_line(zeile, sp0, sp1: Integer);
  16. FUNCTION bitmapzeile(plane,line: Integer): Ptr;
  17. PROCEDURE busy_pointer;
  18. PROCEDURE normal_pointer;
  19. PROCEDURE desaster(meldung: Str80);
  20. PROCEDURE sysinit(version: Str);
  21. PROCEDURE sysclean;
  22.  
  23. VAR Con: Ptr;  { darf nicht vom ExitServer geschlossen werden, komisch }
  24.  
  25. { ---------------------------------------------------------------------- }
  26.  
  27. IMPLEMENTATION;
  28.  
  29. {$ opt b- }
  30. {$ incl "exec.lib", "intuition.lib", "graphics.lib" }
  31. {$ incl "diskfont.lib", "dos.lib", "req.lib" }
  32.  
  33. TYPE WordArr36 = ARRAY [1..36] OF Word;
  34.  
  35. VAR NeuerScreen: NewScreen;  STATIC;
  36.     MyScreen: ^Screen;
  37.     titel: Str80;  STATIC;
  38.     NeuesWindow: NewWindow;  STATIC;
  39.     myprocess: p_Process;
  40.     MyWindow,oldwindowptr: ^Window;
  41.     Menue1: Menu; STATIC;
  42.     Mi: Array[1..5] of MenuItem; STATIC;
  43.     MiT: Array[1..5] of IntuiText; STATIC;
  44.     breite,hoehe: integer;
  45.     topazAttr,teleAttr: TextAttr;
  46.     MyFont: ^TextFont;
  47.     BusyPointerData: ^WordArr36;
  48.     { für die req.library: }
  49.     MyFileReq: ReqFileRequester; STATIC;
  50.     pfad: Array[0..DSIZE] of Char; STATIC;
  51.     name: Array[0..FCHARS] of Char; STATIC;
  52.     pfadname: Array[-DSIZE..FCHARS] of Char; STATIC;
  53.  
  54. FUNCTION abbruch_test{: Boolean};
  55. { Schaut, ob das Menue 'Quit' angewählt wurde. }
  56. { Aufruf am besten in der Form: "ende := ende OR abbruch_test", wobei }
  57. { <ende> eine globale Variable ist }
  58. VAR Msg: ^IntuiMessage;
  59.     item,men,menitem,subitem: Word;
  60.     item_address: ^MenuItem;
  61. BEGIN
  62.   abbruch_test := False;
  63.   Msg := Get_Msg(MyWindow^.UserPort);
  64.   IF Msg <> Nil THEN BEGIN
  65.     IF Msg^.class = MENUPICK THEN BEGIN
  66.       item := Msg^.Code;
  67.       WHILE item<>MENUNULL DO BEGIN
  68.         { item nach Menue, Menuepunkt und Untermenue aufschlüsseln }
  69.         men:=item AND %00011111;
  70.         menitem:=(item SHR 5) AND %00111111;
  71.         subitem:=(item SHR 11) AND %00011111;
  72.         IF (men=0) AND (menitem=0) THEN
  73.           abbruch_test := True;
  74.         item_address := ItemAddress(^Menue1,item);
  75.         item := item_address^.NextSelect;
  76.       END;
  77.     END;
  78.     Reply_Msg(Msg);
  79.   END;
  80. END;
  81.  
  82. FUNCTION readkey{: Char};
  83. begin
  84.   readkey := ReadCon(Con);
  85. end;
  86.  
  87. FUNCTION waitkey{: Char};
  88. var taste: char;
  89.     sig: long;
  90. begin
  91.   repeat
  92.     sig := wait(-1);
  93.     taste := ReadCon(Con);
  94.   until taste <> chr(0);
  95.   waitkey := taste;
  96. end;
  97.  
  98. FUNCTION ja_nein{: Boolean};
  99. var ch: char;
  100. begin
  101.   write(' (J/N)?  ');
  102.   repeat
  103.     delay(2); write(#8' '#8);
  104.     ch := waitkey;
  105.     if (ord(ch) mod 128)>31 then write(ch) else write(' ');
  106.   until ch in ['j', 'J', 'n', 'N']
  107.   ja_nein := ch in ['j', 'J'];
  108. end;
  109.  
  110. FUNCTION fileselect{(was_los: str80; speichern: boolean;
  111.                                    var selected: str80): Boolean};
  112. { benutzt, wenn vorhanden, den Filerequester der req.library }
  113. VAR i,p,l: Integer;
  114. BEGIN
  115.   fileselect := FALSE;
  116.   IF ReqBase=Nil THEN BEGIN
  117.     Write(was_los,#155' p: '); { Cursor sichtbar machen! }
  118.     IF NOT EmptyLn(input) THEN BEGIN
  119.       ReadLn(selected); fileselect := TRUE;
  120.     END;
  121.   END ELSE BEGIN
  122.     l := length(selected);
  123.     p := 0;
  124.     { selected in pfad und name spalten }
  125.     for i := 1 to l do
  126.       if (selected[i]='/') or (selected[i]=':') then p := i;
  127.     if p=0 then pfad := '' else pfad := copy(selected,1,p);
  128.     if p=l then name := '' else name := copy(selected,p+1,l-p);
  129.     with MyFileReq do begin
  130.       VersionNumber := REQVERSION;
  131.       Title := was_los;
  132.       PathName := pfadname;   { Str-Zeiger auf meinen Puffer setzen }
  133.       Dir := pfad;
  134.       _File := name;
  135.       WindowLeftEdge := 128;
  136.       WindowTopEdge := 25;
  137.       Flags := FRQABSOLUTEXYM;
  138.       if speichern then
  139.         Flags := Flags or FRQSAVINGM
  140.       else
  141.         Flags := Flags or FRQLOADINGM;
  142.       filenamescolor := 6;
  143.       dirnamescolor := 3;
  144.       devicenamescolor := 6;
  145.       detailcolor := 1;
  146.       blockcolor := 0;
  147.       gadgettextcolor := 1;
  148.       textmessagecolor := 6;
  149.       stringnamecolor := 6;
  150.       stringgadgetcolor := 4;
  151.       boxbordercolor := 6;
  152.       gadgetboxcolor := 4;
  153.     end;
  154.     if FileRequester(^MyFileReq) then begin
  155.       selected := pfadname;
  156.       fileselect := true;
  157.     end;
  158.   END;
  159. END;
  160.  
  161. PROCEDURE telltime{(VAR day,min,tic: Long)};
  162. VAR time: DateStamp;
  163. BEGIN
  164.   IF _DateStamp(^time)<>Nil THEN BEGIN
  165.     day := time.ds_Days;
  166.     min := time.ds_Minute;
  167.     tic := time.ds_Tick;
  168.   END;
  169. END;
  170.  
  171. PROCEDURE stretch_line{(zeile, sp0, sp1: Integer)};
  172. { Streckt eine Textzeile am Bildschirm von sp0 bis einschließlich sp1 auf }
  173. { doppelte Höhe. }
  174. { Zeilen und Spalten werden, wie bei GotoXY üblich, ab 1 gezählt! }
  175. VAR charx,chary,i,y0,x0,breite: Integer;
  176. BEGIN
  177.   charx := MyWindow^.RPort^.TxWidth;
  178.   chary := MyWindow^.RPort^.TxHeight;
  179.   y0 := (zeile-1)*chary;
  180.   x0 := (sp0-1)*charx; breite := (sp1-sp0+1)*charx;
  181.   FOR i := chary-1 DOWNTO 0 DO BEGIN
  182.     ClipBlit(MyWindow^.RPort,x0,y0+i,MyWindow^.RPort,x0,y0+2*i,breite,1,$C0);
  183.     ClipBlit(MyWindow^.RPort,x0,y0+i,MyWindow^.RPort,x0,y0+2*i+1,breite,1,$C0);
  184.   END;
  185. END;
  186.  
  187. FUNCTION bitmapzeile{(plane,line: Integer): Ptr};
  188. VAR map: p_BitMap;
  189.     y0: Integer;
  190. BEGIN
  191.   map := MyWindow^.RPort^.BitMap;
  192.   y0 := MyWindow^.TopEdge + MyWindow^.BorderTop;
  193.   bitmapzeile := Ptr(Long(map^.Planes[plane]) + (y0+line)*map^.BytesPerRow);
  194. END;
  195.  
  196. PROCEDURE busy_pointer;
  197. BEGIN
  198.   IF BusyPointerData<>Nil THEN
  199.     SetPointer(MyWindow, BusyPointerData, 16, 16, -6, 0);
  200. END;
  201.  
  202. PROCEDURE normal_pointer;
  203. BEGIN
  204.   ClearPointer(MyWindow);
  205. END;
  206.  
  207. PROCEDURE desaster{(meldung: Str80)};
  208. { erzeugt einen Alert }
  209. var egal: boolean;
  210.     buf: string;
  211.     xpos: integer;
  212. begin
  213.   xpos := 320 - 4*length(meldung);
  214.   buf := '   '+meldung;
  215.   buf[1] := chr(Hi(xpos)); buf[2] := chr(Lo(xpos));
  216.   buf[3] := chr(18);
  217.   buf [length(meldung)+5] := chr(0);
  218.   egal := DisplayAlert(RECOVERY_ALERT,buf,32);
  219. end;
  220.  
  221. PROCEDURE sysinit{(version: Str)};
  222. const charx = 8;  { für Menuetexte }
  223.       chary = 8;
  224. var i: integer;
  225.     flags, cflags, breit: Word;
  226.     egal: long;
  227. begin
  228.   { Zuerst Zeiger für den zugehörigen ExitServer initialisieren: }
  229.   IntuitionBase := Nil; GfxBase := Nil; DiskFontBase := Nil; ReqBase := Nil;
  230.   MyScreen := Nil; MyWindow := Nil; MyFont := Nil; oldwindowptr := Nil;
  231.   BusyPointerData := Nil;
  232.   { Filerequester-Struktur initialisieren (in C wäre das nicht nötig!), }
  233.   { muß an dieser Stelle geschehen, damit PurgeFiles nicht abstürzt! }
  234.   for i := 0 to SizeOf(ReqFileRequester)-1 do
  235.     Mem[Long(^MyFileReq)+i] := 0;
  236.   { Libraries etc. öffnen: }
  237.   IntuitionBase := OpenLibrary('intuition.library',0);
  238.   GfxBase := OpenLibrary('graphics.library',0);
  239.   DiskFontBase := OpenLibrary('diskfont.library',0);
  240.   ReqBase := OpenLibrary('req.library',0);
  241.   if IntuitionBase=Nil then Error('Can''t open intuition.library!');
  242.   if GfxBase=Nil then Error('Can''t open graphics.library!');
  243.   if DiskfontBase=Nil then desaster('Can''t open diskfont.library !!!');
  244.   {if ReqBase=Nil then  desaster('Can''t open req.library !!!');}
  245.   { Screen: }
  246.   breite := 640;
  247.   hoehe := 256;
  248.   titel := copy(version,7,length(version)-6);
  249.   topazAttr := TextAttr('topaz.font',8,FS_NORMAL,FPF_ROMFONT);
  250.   NeuerScreen := NewScreen(0,0,breite,hoehe,3,6,4,HIRES or GENLOCK_VIDEO,
  251.     CUSTOMSCREEN,^topazAttr,titel,Nil,Nil);
  252.   MyScreen := OpenScreen(^NeuerScreen);
  253.   for i := 0 to 7 do
  254.     SetRGB4(^MyScreen^.ViewPort, i, 15*( i        and 1),
  255.                                     15*((i div 2) and 1),
  256.                                     15*((i div 4) and 1));
  257.   { Fenster und Menue: }
  258.   NeuesWindow := NewWindow(0,16,breite,hoehe-16,0,7, MENUPICK,
  259.            ACTIVATE or BORDERLESS or BACKDROP,
  260.            Nil,Nil,Nil,MyScreen,Nil,170,100,breite,hoehe,CUSTOMSCREEN);
  261.   MyWindow := OpenWindow(^NeuesWindow);
  262.   Menue1 := Menu(Nil,10,0,8*charx,0,MENUENABLED,'Projekt',^Mi[1],0,0,0,0);
  263.   { besonders häufige Flagkombinationen: }
  264.   Flags := ITEMTEXT or ITEMENABLED or HIGHCOMP; CFlags := Flags or COMMSEQ;
  265.   { Menueeinträge und Texte: }
  266.   { Projekt: Quit }
  267.   breit := (4+3)*charx + COMMWIDTH;
  268.   for i := 1 to 1 do
  269.     Mi[i] := MenuItem(Nil,0,(chary+2)*(i-1),breit,chary+2,CFlags,
  270.                    0,^MiT[i],Nil,chr(0),Nil,MENUNULL);
  271.   Mi[1].NextItem := Nil;    Mi[1].Command := 'Q';
  272.   MiT[1] := IntuiText(0,7,JAM1,5,1,Nil, 'Quit',Nil);
  273.   if not SetMenuStrip(MyWindow,^Menue1) then
  274.     Error('Cannot install the menues - damn!');
  275.   { Font: }
  276.   teleAttr := TextAttr('videotext.font',9,FS_NORMAL,FPF_DISKFONT);
  277.   if DiskFontBase<>Nil then
  278.     MyFont := OpenDiskFont(^teleAttr);
  279.   if MyFont<>Nil then
  280.     egal := SetFont(MyWindow^.RPort,MyFont)
  281.   else
  282.     desaster('Can''t open videotext.font !!!');
  283.   Con := OpenConsole(MyWindow);
  284.   SetStdIO(Con);
  285.   BusyPointerData := Ptr(AllocMem(SizeOf(WordArr36),MEMF_CHIP));
  286.   IF BusyPointerData <> Nil THEN
  287.     BusyPointerData^ := WordArr36(
  288.       $0000,$0000,
  289.       $0400,$07C0,$0000,$07C0,$0100,$0380,$0000,$07E0,
  290.       $07C0,$1FF8,$1FF0,$3FEC,$3FF8,$7FDE,$3FF8,$7FBE,
  291.       $7FFC,$FF7F,$7EFC,$FFFF,$7FFC,$FFFF,$3FF8,$7FFE,
  292.       $3FF8,$7FFE,$1FF0,$3FFC,$07C0,$1FF8,$0000,$07E0,
  293.       $0000,$0000
  294.     );
  295.   { meine Task finden und System Requests auf meinen Screen umleiten }
  296.   myprocess := ptr(FindTask(Nil));
  297.   oldwindowptr := myprocess^.pr_WindowPtr;
  298.   myprocess^.pr_WindowPtr := MyWindow;
  299. end;
  300.  
  301. PROCEDURE sysclean;
  302. begin
  303.   if oldwindowptr<>Nil then myprocess^.pr_WindowPtr := oldwindowptr;
  304.   if ReqBase<>Nil then begin
  305.     PurgeFiles(^MyFileReq); CloseLibrary(ReqBase); end;
  306.   if MyWindow<>Nil then begin
  307.     ClearMenuStrip(MyWindow);
  308.     CloseWindow(MyWindow);
  309.   end;
  310.   if MyScreen<>Nil then if CloseScreen(MyScreen) then;
  311.   if MyFont<>Nil then CloseFont(MyFont);
  312.   if IntuitionBase<>Nil then CloseLibrary(IntuitionBase);
  313.   if GfxBase<>Nil then CloseLibrary(GfxBase);
  314.   if DiskFontBase<>Nil then CloseLibrary(DiskFontBase);
  315.   IF BusyPointerData <> Nil THEN FreeMem(Ptr(BusyPointerData),SizeOf(WordArr36));
  316.   { festhalten, daß alles geschlossen ist: }
  317.   ReqBase := Nil;
  318.   MyWindow := Nil;
  319.   MyScreen := Nil;
  320.   MyFont := Nil;
  321.   IntuitionBase := Nil;
  322.   GfxBase := Nil;
  323.   DiskFontBase := Nil;
  324.   BusyPointerData := Nil;
  325. end;
  326.  
  327. BEGIN  { Initialisierungsteil }
  328. END.
  329.